      subroutine printscreen(pcxname)
c
c This routine is called in graphics mode in order to dump
c the whole screen into a .PCX file. The argument is the
c name of the file to create, and is limited to 13 chars i.e.
c intended to go in the current directory. 
c I have only really stress-tested this in 16 colour mode,
c 1 bit per pixel. I usually work in MAXRESMODE ....
c
c For 256 colour mode then the PCX file needs a different
c method of storing the colourmap (i.e. at the end), which
c is not covered here ...
c
c J.J.Bunn, 1994. Placed in the Public Domain, for what it's
c worth. Please keep my name on it anyway!
c
      implicit integer(a-z)
      include 'fgraph.fd'
      logical fexists,nocompress
      integer*1 buffer [allocatable] (:)
      byte b,bt
      integer*2 ic
      character*13 pcxname
      character*6 ctext
      structure /PCX_header/
       union
        map
         character*128 char
        end map
        map
         byte manu
         byte version
         byte encoding
         byte bitsPpixel
         integer*2 xmin
         integer*2 ymin
         integer*2 xmax
         integer*2 ymax
         integer*2 hres
         integer*2 vres
         byte colormap(48)
         byte reserved
         byte nplanes
         integer*2 bytesPline
         integer*2 palette
         byte filler(58)
        end map
       end union
      end structure
      record /videoconfig/ screen
      record /PCX_header/ pcx
      byte red(16),green(16),blue(16)
      equivalence (bt,ic)
      save red,green,blue
      data red  /#00,#00,#00,#00,#A8,#A8,#A8,#A8,
     & #54,#54,#54,#54,#FC,#FC,#FC,#FC/
      data green/#00,#00,#A8,#A8,#00,#00,#54,#A8,
     & #54,#54,#FC,#FC,#54,#54,#FC,#FC/
      data blue /#00,#A8,#00,#A8,#00,#A8,#00,#A8,
     & #54,#FC,#54,#FC,#54,#FC,#54,#FC/
c
c Setting nocompress = .true. will prevent run-length encoding
c of the image byte stream ... not usually what we want!
c
      nocompress = .false.
      inquire(file=pcxname,exist=fexists)
      if(fexists) then
         open(1,file=pcxname,status='old',
     &        form='unformatted',recl=512,err=900)
         close(1,status='delete')
      endif
      open(1,file=pcxname,status='new',access='direct',
     &     form='binary',recl=1,err=900)
      call getvideoconfig(screen)
      width = screen.numxpixels
c      colors = screen.numcolors
      height = screen.numypixels
c
c Calls to "transient" are commented out. In my package,
c transient is a routine that posts info messages in a
c designated area of the screen.
c
      call transient('Patience please ... !')
      call setviewport(0,0,width-1,height-1)
c
c I compress in 4 bands of y, since doing the whole
c screen in one go can exhaust the memory too easily.
c npass could be calculated from free memory ....
c
      npass = 4
      ipass = 0
      iyband = height/npass - 1
      iyhigh = -1
 100  ipass = ipass + 1
      iylow = iyhigh + 1
      iyhigh = min(iylow + iyband,height-1)

      imsize = imagesize(0,iylow,width-1,iyhigh)
      if(ipass.eq.1) then
c
c first band .. allocate the buffer
c
         if(allocated(buffer)) deallocate(buffer)
         allocate(buffer(imsize), stat=error)
         if(error.ne.0) goto 910
      endif
      call getimage(0,iylow,width-1,iyhigh,buffer)
      if(ipass.eq.1) then
c
c create the PCX header and write it out
c
         pcx.manu = 10           
         pcx.version = 5
         pcx.encoding = 1
         pcx.xmin = 0
         pcx.xmax = width-1
         pcx.ymin = 0
         pcx.ymax = height-1
         pcx.hres = width
         pcx.vres = height
c
c I've hard coded the 16 colour values here ...
c this would require changing for 256 colours.
c
         do i=1,16
            pcx.colormap(3*i-2) = red(i)
            pcx.colormap(3*i-1) = green(i)
            pcx.colormap(3*i) = blue(i)
         end do
         do i=1,58
            pcx.filler(i) = 0
         end do
c
c should be calculated from screen.numcolors ...
c
         pcx.nplanes = 4
         pcx.bitsPpixel = 1
         pcx.bytesPline = width *pcx.bitsPpixel/8
         pcx.palette = 1
         write(1) pcx.char
c PCX header length ... data follow
         nout = 128   
         widbyte = pcx.bytesPline*pcx.nplanes
      endif
c
c first four bytes are info
c
      ipos = 5
c
c run length encode the bytes ...
c
    2 if(ipos.gt.imsize) goto 5
      b = buffer(ipos)
      icount = 1
      if(nocompress) goto 4
      endscan = (ifix((ipos-5)/widbyte) + 1)*widbyte
      endscan = min(imsize,endscan+4)
      if(ipos.eq.endscan) goto 4
      do 3 i=ipos+1,endscan
         if(buffer(i).ne.b) goto 4
         if(icount.ge.#3F) goto 4
         icount = icount + 1
    3 continue
    4 continue
      ipos = ipos + icount
      if(icount.ne.1.or.(b.and.#C0).ne.0) then
c
c if there is more than one byte the same, or one or both of
c the top two bits of the current byte is set, write the count byte
c and the data byte
c
         ic = icount .or. #C0   ! bt is equivalenced to this
         write(1) bt
         write(1) b
         nout = nout + 2
      else
c
c the byte is a singleton, and neither of the two top bits is
c set
c
         write(1) b
         nout = nout + 1
      endif
      goto 2
    5 if(ipass.lt.npass) goto 100
c      write(ctext,'(i6)') nout
c      call transient(ctext//' bytes written to '//pcxname//' OK!')
      close(1)
      goto 1000
  900 continue
c      call transient('Cannot open PCX file for writing !')
      goto 1000
  910 continue
c      call transient('Insufficient memory for screen dump, sorry.')
      if(ipass.gt.1) close(1,status='delete')
 1000 continue
      if(allocated(buffer)) deallocate(buffer)
      end
